5
48
1500
21
10
terrestrial_daily3
terrestrial_30min5
Error : The fig.showtext code chunk option must be TRUE
7
Error : The fig.showtext code chunk option must be TRUE
7
---
title: "NEON4CAST Dashboard"
output:
flexdashboard::flex_dashboard:
theme:
version: 4
bootswatch: lux
orientation: columns
vertical_layout: fill
source_code: embed
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(plotly)
library(ggiraph)
library(clock)
library(dbplyr)
library(RSQLite)
source("R/plotly_helpers.R")
thematic::thematic_rmd(font = "auto")
```
Home
=====
```{r include=FALSE}
combined <- read_csv("https://data.ecoforecast.org/analysis/combined_forecasts_scores.csv.gz")
```
Column {data-width=650}
-----------------------------------------------------------------------
### NEON Ecological Forecasting Challenge sites
```{r}
## FIXME color code by number of challenges at each site?
challenges <- combined %>% select(theme, siteID) %>% distinct() %>%
separate(siteID, into = c("siteID", "plot")) %>%
select(theme, siteID) %>%
distinct()
library(sf)
library(tmap)
geo <- jsonlite::read_json("https://github.com/eco4cast/neon4cast/raw/main/inst/extdata/geo.json", TRUE)
site_id <- gsub(", .*$", "", geo$geographicDescription)
bb <- geo$boundingCoordinates[1:4] %>% mutate_all(as.numeric) %>% mutate(siteID = site_id)
bb <- left_join(bb, challenges, by = "siteID")
neon <- st_as_sf(bb, coords = c("westBoundingCoordinate", "northBoundingCoordinate"), crs = 4326)
tmap::tmap_mode("view")
tm_shape(neon) + tm_dots(col="theme", alpha=.4, size = .1)
```
Column {data-width=350}
-----------------------------------------------------------------------
## Stats
### Challenges
```{r}
flexdashboard::valueBox(5, color = "primary")
```
### Teams
```{r}
total_teams <- combined %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total_teams, color = "success")
```
### Total Forecasts
```{r}
total_forecasts <- combined %>% select(team, forecast_start_time) %>% distinct() %>% count()
flexdashboard::valueBox(total_forecasts, color = "info")
```
Phenology
==========
Column {data-width=650}
-----------------------------------------------------------------------
### Phenology (Greeness)
```{r}
## determine these more cleverly
start <- as.Date("2021-05-01")
end <- Sys.Date() %>% clock::add_months(1)
## Get most recent submission per team
pheno_teams <- combined %>% filter(theme == "phenology") %>%
select(team, forecast_start_time) %>% distinct() %>%
group_by(team) %>%
slice_max(forecast_start_time)
pheno_latest <- inner_join(pheno_teams, combined)
p <- pheno_latest %>%
filter(time > start, time < end, target == "gcc_90") %>%
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
geom_line(aes(time, mean, col = team)) +
geom_point(aes(time, obs), size = .1) +
facet_wrap(~siteID)
gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)
gp
```
### Phenology (Redness)
```{r}
p <- pheno_latest %>%
filter(time > start, time < end, target == "rcc_90") %>%
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
geom_line(aes(time, mean, col = team)) +
geom_point(aes(time, obs), size = .1) +
facet_wrap(~siteID)
gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)
gp
```
Column {data-width=350}
-----------------------------------------------------------------------
### Teams
```{r}
total <- combined %>% filter(theme == "phenology") %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```
### Leaderboard (target: greeness)
```{r}
con <- DBI::dbConnect(RSQLite::SQLite(), tempfile())
dbWriteTable(con, "combined", combined, overwrite=TRUE)
pheno <- tbl(con, "combined") %>% filter(theme == "phenology") %>%
select(siteID, target, time, team, forecast_start_time, crps)
## expand a table to all possible observations (target, siteID, time)
## for each team, for each forecast_start_time:
all <- pheno %>% expand(team, target, siteID, time, forecast_start_time)
## Use this list to make explicit NA for any observation for which a forecast was not provided
na_filled <- pheno %>% right_join(all)
## Fill in any missing observation with the most recent forecast made prior to the start_time
self_fill <- na_filled %>%
window_order(team, target, time, forecast_start_time) %>% #
group_by(team, target, siteID, time) %>%
fill(crps, .direction="up")
## We will now fill all remaining NAs using the NULL forecast:
null_score <- self_fill %>% ungroup() %>%
filter(team == "EFInull") %>% rename(null = crps) %>% select(-team)
all_filled <- self_fill %>%
left_join(null_score) %>% # add null-score as a separate column
mutate(filled_crps = case_when(is.na(crps) ~ null,
!is.na(crps) ~ crps))
scores <- all_filled %>% filter(target == "gcc_90") %>%
group_by(team) %>%
summarise(mean_crps = mean(filled_crps)) %>%
collect() %>% arrange(mean_crps)
scores %>%
rmarkdown::paged_table()
```
### Leaderboard (target: redness)
```{r}
scores <- all_filled %>% filter(target == "rcc_90") %>%
group_by(team) %>%
summarise(mean_crps = mean(filled_crps)) %>%
collect() %>% arrange(mean_crps)
scores %>%
rmarkdown::paged_table()
```
### Days remaining
```{r}
#days <- (pheno_end_date - Sys.Date() )
#max <- pheno_end_date - pheno_start_date
#gauge(days, min = 0, max = max, symbol = '', gaugeSectors(
# success = c(81, max), warning = c(10, 3), danger = c(0, 2)
#))
```
Aquatics
========
Column {data-width=650}
-----------------------------------------------------------------------
### Aquatics Forecasts
```{r}
start <- as.Date("2021-05-31")
end <- as.Date("2021-08-31")
## Get most recent submission per team
aq_teams <- combined %>% filter(theme == "aquatics") %>%
select(team, forecast_start_time) %>% distinct() %>%
group_by(team) %>%
slice_max(forecast_start_time)
## Heck show all the forecasts
p <- combined %>% #inner_join(aq_teams) %>%
filter(theme == "aquatics", time >= start, time <= end) %>%
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
geom_point(aes(time, obs)) +
geom_line(aes(time, mean, col = team)) +
facet_grid(target~siteID, scales = "free")
gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)
gp
```
Column {data-width=350}
-----------------------------------------------------------------------
### Teams
```{r}
total <- combined %>% filter(theme == "aquatics") %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```
### Leaderboard
```{r}
combined %>%
filter(theme == "aquatics") %>%
group_by(team) %>%
summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
arrange(mean_crps) %>%
rmarkdown::paged_table()
```
### Days elapsed
```{r}
days <- end-start
gauge(days, min = 0, max = end-start, symbol = '', gaugeSectors(
success = c(11, as.numeric(end-start)), warning = c(10, 3), danger = c(0, 2)
))
```
Terrestrial
===========
Column {data-width=650}
-----------------------------------------------------------------------
### Terrestrial Forecasts (Daily)
```{r}
## Could consider displaying older ones
start <- combined %>%
filter(theme == "terrestrial_daily") %>%
select(forecast_start_time) %>%
distinct() %>%
arrange(desc(forecast_start_time))
p <- combined %>%
filter(theme == "terrestrial_daily", forecast_start_time == start[[2,1]]) %>%
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
geom_line(aes(time, mean, col = team)) +
geom_point(aes(time, obs)) +
facet_grid(target ~ siteID, scales = "free")
gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)
gp
```
### Terrestrial Forecasts (30 minute)
```{r}
## Could consider displaying older ones
start <- combined %>%
filter(theme == "terrestrial_30min") %>%
select(forecast_start_time) %>%
distinct() %>%
arrange(desc(forecast_start_time))
p <- combined %>%
filter(theme == "terrestrial_30min", forecast_start_time == start[[2,1]]) %>%
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
geom_line(aes(time, mean, col = team)) +
geom_point(aes(time, obs)) +
facet_grid(target ~ siteID, scales = "free")
gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)
gp
```
Column {data-width=350}
-----------------------------------------------------------------------
### Teams: `terrestrial_daily`
```{r}
total <- combined %>% filter(theme == "terrestrial_daily") %>%
select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```
### Teams: `terrestrial_30min`
```{r}
total <- combined %>% filter(theme == "terrestrial_30min") %>%
select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```
### Leaderboard (daily)
```{r}
combined %>%
filter(theme == "terrestrial_daily") %>%
group_by(team) %>%
summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
arrange(mean_crps) %>%
rmarkdown::paged_table()
```
### Leaderboard (30 minute)
```{r}
combined %>%
filter(theme == "terrestrial_30min") %>%
group_by(team) %>%
summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
arrange(mean_crps) %>%
rmarkdown::paged_table()
```
Ticks
=======
Column {data-width=650}
-----------------------------------------------------------------------
### Ticks
```{r}
## Could consider displaying older ones
start <- combined %>%
filter(theme == "ticks") %>%
select(forecast_start_time) %>%
distinct() %>%
arrange(desc(forecast_start_time))
p <- combined %>%
filter(theme == "ticks", forecast_start_time == start[[2,1]]) %>% # second most recent start time
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95,
fill = team, lty=target), alpha = 0.2) +
geom_line(aes(time, mean, col = team, lty=target)) +
geom_point(aes(time, obs, shape=target)) +
facet_wrap(~siteID)
## ggiraph also supports ggplot-syntax-based controls
ggiraph(ggobj = p)
```
Column {data-width=350}
-----------------------------------------------------------------------
### Teams
```{r}
total <- combined %>% filter(theme == "ticks") %>%
select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```
### Leaderboard
```{r}
combined %>%
filter(theme == "ticks") %>%
group_by(team) %>%
summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
arrange(mean_crps) %>%
rmarkdown::paged_table()
```
Beetles
=======
Column {data-width=650}
-----------------------------------------------------------------------
### Beetles Forecasts
```{r fig.width=8, fig.height=16}
## determine these more cleverly
start <- combined %>%
filter(theme == "beetles") %>%
select(forecast_start_time) %>%
distinct() %>%
arrange(desc(forecast_start_time))
p <- combined %>%
filter(theme == "beetles",
target == "richness",
forecast_start_time == start[[1,1]]) %>% # second most recent start time
ggplot() +
geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
geom_line(aes(time, mean, col = team)) +
geom_point(aes(time, obs)) +
facet_wrap(~siteID)
ggiraph(ggobj = p)
```
Column {data-width=350}
-----------------------------------------------------------------------
### Teams
```{r}
total <- combined %>% filter(theme == "ticks") %>%
select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```
### Leaderboard
```{r}
combined %>%
filter(theme == "beetles") %>%
group_by(team) %>%
summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
arrange(mean_crps) %>%
rmarkdown::paged_table()
```